home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tk8.0 / tests / msgbox.test < prev    next >
Encoding:
Text File  |  1997-08-15  |  4.5 KB  |  158 lines  |  [TEXT/ALFA]
  1. # This file is a Tcl script to test out Tk's "tk_messageBox" command.
  2. # It is organized in the standard fashion for Tcl tests.
  3. #
  4. # Copyright (c) 1996 Sun Microsystems, Inc.
  5. #
  6. # See the file "license.terms" for information on usage and redistribution
  7. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  8. #
  9. # SCCS: @(#) msgbox.test 1.7 97/07/31 10:05:25
  10. #
  11.  
  12. if {[string compare test [info procs test]] == 1} {
  13.     source defs
  14. }
  15.  
  16. test msgbox-1.1 {tk_messageBox command} {
  17.     list [catch {tk_messageBox -foo} msg] $msg
  18. } {1 {unknown option "-foo", must be -default, -icon, -message, -parent, -title or -type}}
  19. test msgbox-1.2 {tk_messageBox command} {
  20.     list [catch {tk_messageBox -foo bar} msg] $msg
  21. } {1 {unknown option "-foo", must be -default, -icon, -message, -parent, -title or -type}}
  22.  
  23. catch {tk_messageBox -foo bar} msg
  24. regsub -all ,      $msg "" options
  25. regsub \"-foo\" $options "" options
  26.  
  27. foreach option $options {
  28.     if {[string index $option 0] == "-"} {
  29.     test msgbox-1.3 {tk_messageBox command} {
  30.         list [catch {tk_messageBox $option} msg] $msg
  31.     } [list 1 "value for \"$option\" missing"]
  32.     }
  33. }
  34.  
  35. test msgbox-1.4 {tk_messageBox command} {
  36.     list [catch {tk_messageBox -default} msg] $msg
  37. } {1 {value for "-default" missing}}
  38.  
  39. test msgbox-1.5 {tk_messageBox command} {
  40.     list [catch {tk_messageBox -type foo} msg] $msg
  41. } {1 {invalid message box type "foo", must be abortretryignore, ok, okcancel, retrycancel, yesno or yesnocancel}}
  42.  
  43. test msgbox-1.6 {tk_messageBox command} {
  44.     list [catch {tk_messageBox -default 1.1} msg] $msg
  45. } {1 {invalid default button "1.1"}}
  46.  
  47. test msgbox-1.7 {tk_messageBox command} {
  48.     list [catch {tk_messageBox -default foo} msg] $msg
  49. } {1 {invalid default button "foo"}}
  50.  
  51. test msgbox-1.8 {tk_messageBox command} {
  52.     list [catch {tk_messageBox -type yesno -default 3} msg] $msg
  53. } {1 {invalid default button "3"}}
  54.  
  55. test msgbox-1.9 {tk_messageBox command} {
  56.     list [catch {tk_messageBox -icon foo} msg] $msg
  57. } {1 {invalid icon "foo", must be error, info, question or warning}}
  58.  
  59. test msgbox-1.10 {tk_messageBox command} {
  60.     list [catch {tk_messageBox -parent foo.bar} msg] $msg
  61. } {1 {bad window path name "foo.bar"}}
  62.  
  63. if {[info commands tkMessageBox] == ""} {
  64.     set isNative 1
  65. } else {
  66.     set isNative 0
  67. }
  68.  
  69. if {$isNative && ![info exists INTERACTIVE]} {
  70.     puts " Some tests were skipped because they could not be performed"
  71.     puts " automatically on this platform. If you wish to execute them"
  72.     puts " interactively, set the TCL variable INTERACTIVE and re-run"
  73.     puts " the test"
  74.     return
  75. }
  76.  
  77. proc ChooseMsg {parent btn} {
  78.     global isNative
  79.     if {!$isNative} {
  80.     after 100 SendEventToMsg $parent $btn mouse
  81.     }
  82. }
  83.  
  84. proc ChooseMsgByKey {parent btn} {
  85.     global isNative
  86.     if {!$isNative} {
  87.     after 100 SendEventToMsg $parent $btn key
  88.     }
  89. }
  90.  
  91. proc PressButton {btn} {
  92.     event generate $btn <Enter>
  93.     event generate $btn <ButtonPress-1> -x 5 -y 5
  94.     event generate $btn <ButtonRelease-1> -x 5 -y 5
  95. }
  96.  
  97. proc SendEventToMsg {parent btn type} {
  98.     if {$parent != "."} {
  99.     set w $parent.__tk__messagebox
  100.     } else {
  101.     set w .__tk__messagebox
  102.     }
  103.     if ![winfo ismapped $w.$btn] {
  104.     update
  105.     }
  106.     if {$type == "mouse"} {
  107.     PressButton $w.$btn
  108.     } else {
  109.     event generate $w <Enter>
  110.     focus $w
  111.     event generate $w.$btn <Enter>
  112.     event generate $w <KeyPress> -keysym Return
  113.     }
  114. }
  115.  
  116. set parent .
  117.  
  118. set specs {
  119.     {"abortretryignore"  MB_ABORTRETRYIGNORE  3  {"abort"  "retry"  "ignore"}} 
  120.     {"ok"           MB_OK            1  {"ok"                      }} 
  121.     {"okcancel"      MB_OKCANCEL           2  {"ok"     "cancel"         }} 
  122.     {"retrycancel"      MB_RETRYCANCEL       2  {"retry"  "cancel"         }} 
  123.     {"yesno"          MB_YESNO           2  {"yes"    "no"             }} 
  124.     {"yesnocancel"      MB_YESNOCANCEL       3  {"yes"    "no"     "cancel"}}
  125. }
  126.  
  127. #
  128. # Try out all combinations of (type) x (default button) and
  129. # (type) x (icon).
  130. #
  131. foreach spec $specs {
  132.     set type [lindex $spec 0]
  133.     set buttons [lindex $spec 3]
  134.  
  135.     set button [lindex $buttons 0]
  136.     test msgbox-2.1 {tk_messageBox command} {
  137.     ChooseMsg $parent $button
  138.     tk_messageBox -title Hi -message "Please press $button" \
  139.         -type $type
  140.     } $button
  141.  
  142.     foreach icon {warning error info question} {
  143.     test msgbox-2.2 {tk_messageBox command -icon option} {
  144.         ChooseMsg $parent $button
  145.         tk_messageBox -title Hi -message "Please press $button" \
  146.         -type $type -icon $icon
  147.     } $button
  148.     }
  149.  
  150.     foreach button $buttons {
  151.     test msgbox-2.3 {tk_messageBox command} {
  152.         ChooseMsg $parent $button
  153.         tk_messageBox -title Hi -message "Please press $button" \
  154.         -type $type -default $button
  155.     } "$button"
  156.     }
  157. }
  158.